home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / emit-code.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  37KB  |  1,032 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; Generate code from an analyzed code tree.
  4. ;;; 3 types of rvar: a var-name string, :LIVE or :DEAD
  5. (defun emit-code (tree &optional (rvar :live) (rtype t))
  6.   (unless (null tree)
  7.     (etypecase tree
  8.       (var-ref (emit-var-ref tree rvar rtype))
  9.       (var-def (emit-var-def tree rvar rtype))
  10.       (constant (emit-constant tree rvar rtype))
  11.       (function-call (emit-function-call tree rvar rtype))
  12.       (tag-control-point (emit-tag-control-point tree))
  13.       (control-transfer (emit-control-transfer tree))
  14.       (branch (emit-branch tree rvar rtype))
  15.       (unwind-protect (emit-unwind-protect tree rvar rtype))
  16.       (mvalues (emit-values tree rvar rtype))
  17.       (seq (emit-seq tree rvar rtype))
  18.       (c-code (emit-c-code tree rvar rtype)))))
  19.  
  20. (defun emit-c-code (tree rvar rtype)
  21.   (let ((result-var (result-var-name rvar)))
  22.     (maybe-emit-assignment result-var)
  23.     (emit-c (c-code-string tree))
  24.     (emit-c "~%")
  25.     (emit-return-if-tail result-var tree rvar rtype)))
  26.  
  27. (defun result-var-name (rvar)
  28.   (if (stringp rvar)
  29.       rvar
  30.       (ecase rvar
  31.     (:live (tmp-var-name))
  32.     (:dead rvar))))
  33.  
  34. (defun maybe-emit-assignment (rvar)
  35.   (unless (eq rvar :dead) (emit-c "~A = " rvar)))
  36.  
  37. (defun emit-return-if-tail (value tree rvar rtype)
  38.   (declare (ignore rtype))
  39.   (if (code-tail? tree)
  40.       (emit-lc tree "return(~A);~%" value)
  41.       (if (stringp rvar)
  42.       (progn (unless (eq rvar value)
  43.            (emit-source-line tree)
  44.            (emit-c "~A = ~A;~%" rvar value))
  45.          rvar)
  46.       value)))
  47.  
  48. (defun emit-constant (tree rvar rtype)
  49.   (emit-return-if-tail (emit-lref (constant-data tree))
  50.                tree
  51.                rvar
  52.                rtype))
  53.  
  54. (defun emit-var-ref (tree rvar rtype)
  55.   (emit-return-if-tail
  56.    (let ((var (var-ref-var tree)))
  57.      (ecase (var-extent var)
  58.        (:dynamic (var-c-name var))
  59.        (:indefinite (format nil "GET_OE_SLOT(~A,~D)"
  60.                 (proc-oe-var
  61.                  (var-ref-innermost-proc tree))
  62.                 (lookup-outer-environment-offset var)))))
  63.    tree
  64.    rvar
  65.    rtype))
  66.  
  67. (defun emit-var-def (tree rvar rtype)
  68.   (let* ((var (var-def-var tree))
  69.      (value
  70.       (ecase (var-extent var)
  71.         (:dynamic (emit-code (var-def-value tree)
  72.                  (var-c-name var)
  73.                  t))
  74.         (:indefinite
  75.          (let ((value (emit-code (var-def-value tree) :live t)))
  76.            (emit-c  "SET_OE_SLOT(~A,~D,~A);~%"
  77.             (proc-oe-var
  78.              (var-def-innermost-proc tree))
  79.             (lookup-outer-environment-offset var)
  80.             value)
  81.            value)))))
  82.     (emit-return-if-tail value tree rvar rtype)))
  83.  
  84. (defun emit-function-call (tree rvar rtype)
  85.   (if (inline-array-op? tree)
  86.       (emit-inline-array-op tree rvar rtype)
  87.       (etypecase tree
  88.     (primitive-call (emit-primitive-call tree rvar rtype))
  89.     (foreign-call (emit-foreign-call tree rvar rtype))
  90.     (named-call (emit-named-call tree rvar rtype))
  91.     (c-struct-op (emit-c-struct-op tree rvar rtype))
  92.     (unnamed-call (emit-unnamed-call tree rvar rtype)))))
  93.  
  94. (defun emit-seq (tree rvar rtype)
  95.   (typecase tree
  96.     (proc (emit-proc tree rvar rtype))
  97.     (named-local (emit-named-local tree rvar rtype))
  98.     (inline-mv-call (emit-inline-mv-call tree rvar rtype))
  99.     (scope-seq (emit-scope-seq tree rvar rtype))
  100.     (tag-seq (emit-tag-seq tree rvar rtype))
  101.     (spec-bind-seq (emit-spec-bind-seq tree rvar rtype))
  102.     (t (emit-body (seq-body tree) rvar rtype))))
  103.  
  104. (defun code-mv? (code)
  105.   (not (null (code-mv-holder code))))
  106.  
  107. (defun emit-proc (tree rvar rtype)
  108.   (emit-proc-extern-declaration tree)
  109.   (if *emitting-proc?*
  110.       (progn (push tree *inner-procs*)
  111.          (emit-return-if-tail
  112.           (if (inner-proc-needs-oe? tree)
  113.           (emit-cons-closure tree (proc-c-name tree))
  114.           (emit-lref tree))
  115.           tree
  116.           rvar
  117.           rtype))
  118.       (emit-proc-code tree)))
  119.  
  120. (defun emit-proc-code (tree)
  121.   (let ((*inner-procs* nil))
  122.     (let ((*emitting-proc?* t))
  123.       (emit-source-line tree)
  124.       (emit-proc-prototype tree)
  125.       (emit-c "~%{~%")
  126.       (let ((*tmp-var-counter* -1))
  127.     (loop for v being the elements of  (proc-vars-to-declare tree)
  128.           using (index i) do
  129.           (progn (emit-c "~ALP ~A; "
  130.                  (proc-volatile tree)
  131.                  (var-c-name v))
  132.              (when (= 2 (mod i 3))
  133.                (emit-c "~%")))
  134.           finally (emit-c "~%"))
  135.     (loop for i from 0 to (proc-max-tmp-var-count tree) do
  136.           (progn (emit-c "~ALP t~A; " (proc-volatile tree) i) 
  137.              (when (= 5 (mod i 6))
  138.                (emit-c "~%")))
  139.           finally (emit-c "~%"))
  140.     (let ((var-info (proc-var-info tree)))
  141.       (if (var-info-hairy? var-info)
  142.           (emit-hairy-arg-code tree)
  143.           (emit-required-argc-check tree))
  144.       (unless (null (proc-start-label tree))
  145.         (emit-c "~A:~%" (proc-start-label tree)))
  146.       (emit-binder-body tree (var-info-all-vars var-info) :live t))
  147.     (emit-c "}~%~%")))
  148.     (loop for p in *inner-procs* do (emit-proc-code p))
  149.     (proc-c-name tree)))
  150.     
  151. (defun emit-inline-mv-call (tree rvar rtype)
  152.   (let* ((var-info (inline-mv-call-var-info tree))
  153.      (all-vars (var-info-all-vars var-info))
  154.      (mv-holder (inline-mv-call-new-holder tree)))
  155.     (emit-c "{~%")
  156.     (emit-misc-storage-decls var-info)
  157.     (emit-c "BEGIN_MV_CALL(~A,~D);~%" mv-holder 0)
  158.     (let ((value-var (emit-code
  159.               (first (inline-mv-call-values tree)) :live t)))
  160.       (unless (null all-vars)
  161.     (emit-c "SET_MV_RETURN_VALUE(~A,0,~A);~%" mv-holder value-var)))
  162.     ;; HEY! use a separate vcnt and skip this step
  163.     (emit-c "if SV_RETURN_P(~A) SET_MV_RETURN_COUNT(~A,1);~%"
  164.         mv-holder mv-holder)
  165.     (emit-hairy-value-code var-info mv-holder)
  166.     (emit-c "END_MV_CALL;~%")
  167.     (let ((body-value (emit-binder-body tree all-vars rvar rtype)))
  168.       (emit-c "}~%")
  169.       body-value)))
  170.  
  171. (defun emit-values (tree rvar rtype)
  172.   (let ((args-lhs (loop for arg in (mvalues-args tree)
  173.             collect (emit-code arg :live t)))
  174.     (holder-name (code-mv-holder tree)))
  175.     (when (code-mv? tree)
  176.       (flet ((emit-fill-holder ()
  177.            (emit-c "SET_MV_RETURN_FLAG(~A);~%" holder-name)
  178.            (emit-c "SET_MV_RETURN_COUNT(~A,~D);~%"
  179.                holder-name (length args-lhs))
  180.            (loop for lhs being the elements of  (cdr args-lhs)
  181.              using (index i)
  182.              do (emit-c "SET_MV_RETURN_VALUE(~A,~D,~A);~%"
  183.                 holder-name (+ i 1) lhs))))
  184.     (if (string= holder-name argc-var-name)    ; constant folding screws eq!
  185.         (progn (emit-c "if (MV_HOLDER_P(~A)) {~%" holder-name)
  186.            (emit-fill-holder)
  187.            (emit-c "}~%"))
  188.         (emit-fill-holder))))
  189.     (emit-return-if-tail (if (null args-lhs) "NIL" (car args-lhs))
  190.              tree
  191.              rvar
  192.              rtype)))
  193.  
  194. (defun inner-proc-needs-oe? (tree)
  195.   (or (not (null (inner-proc-oe-refs tree)))
  196.       (inner-proc-pass-on-oe? tree)))
  197.  
  198. (defun setup-oe-if-needed (tree)
  199.   (etypecase tree
  200.     (top-level-proc
  201.      (unless (null (top-level-proc-oe-vars tree))
  202.        (let ((oe-var (tmp-var-name)))       
  203.      (setf (proc-oe-var tree) oe-var)
  204.      (emit-c "~A = NEW_OE(~D);~%"
  205.          oe-var (length (top-level-proc-oe-vars tree))))))
  206.     (inner-proc
  207.      (when (inner-proc-needs-oe? tree)
  208.        (let ((oe-var (tmp-var-name)))
  209.      (setf (proc-oe-var tree) oe-var)
  210.      (emit-c  "~A = OE;~%" oe-var))))))
  211.  
  212. (defun emit-cons-closure (tree label)
  213.   (let ((result-var (tmp-var-name)))
  214.     (emit-c "~A = MAKE_CLOSURE(~A,~A);~%"
  215.         result-var
  216.         label
  217.         (proc-oe-var (first (inner-proc-parent-chain tree))))
  218.     result-var))
  219.  
  220. (defun emit-spec-bind-seq (tree rvar rtype)
  221.   (let* ((specs (spec-bind-seq-specials tree))
  222.      (values (loop for value in (spec-bind-seq-values tree)
  223.                collect (emit-code value :live t)))
  224.      (symbol-names (mapcar #'(lambda (v)
  225.                    (let ((sym (var-name v)))
  226.                      (emit-data sym)
  227.                      (lisp->c-symbol-name sym)))
  228.                    specs)))
  229.     (loop for val in values
  230.       for name in symbol-names do
  231.       (emit-c "BEGIN_SPEC_BIND(~A,~A);~%" name val))
  232.     (let ((value (emit-body (seq-body tree) :live t)))
  233.       (loop for name in (nreverse symbol-names)
  234.         do (emit-c "END_SPEC_BIND(~A);~%" name))
  235.       (emit-return-if-tail value tree rvar rtype))))
  236.  
  237. (defun emit-body (list rvar rtype)
  238.   (if (atom list)
  239.       (emit-code list :live t)
  240.       (loop with end = (last list)
  241.         for x on list
  242.         for var = (if (eq x end)
  243.               (emit-code (car x) rvar rtype)
  244.               (emit-code (car x) :dead t))
  245.         finally (return var))))
  246.  
  247. (defun emit-binder-body (tree all-vars rvar rtype)
  248.   (loop for var in all-vars
  249.     when (eq (var-extent var) :indefinite) 
  250.     do (emit-c "SET_OE_SLOT(~A,~D,~A);~%"
  251.            (proc-oe-var (var-innermost-proc var))
  252.            (lookup-outer-environment-offset var)
  253.            (var-c-name var)))
  254.   (emit-code (seq-body tree) rvar rtype))
  255.  
  256. (defun emit-named-local (tree rvar rtype)
  257.   (let ((all-vars (named-local-vars tree)))
  258.     (loop for value in (named-local-values tree)
  259.       for var in all-vars
  260.       collect (emit-code value (var-c-name var) t))
  261.     (emit-binder-body tree all-vars rvar rtype)))
  262.  
  263. (defun add-external-proc (name)
  264.   (let ((c-name (lisp->c-proc-name name)))
  265.     (unless (eq (gethash name *external-procs*) :done)
  266.       (setf (gethash name *external-procs*) c-name))
  267.     c-name))
  268.  
  269. (defun emit-named-call (tree rvar rtype)
  270.   (let* ((result-var (result-var-name rvar))
  271.      (arg-lvalues (mapcar #'(lambda (arg)
  272.                   (emit-code arg :live t))
  273.                   (function-call-args tree)))
  274.      (argc (length arg-lvalues))
  275.      (name (function-call-name tree)))
  276.     (if (named-call-emit-as-goto? tree)
  277.     (let ((proc (named-call-emit-as-goto? tree)))
  278.       (loop for var in (var-info-requireds
  279.                 (proc-var-info proc))
  280.         for arg-lvalue in arg-lvalues
  281.         unless (eq (var-c-name var) arg-lvalue)    ; skip useless assign
  282.         do (emit-c "~A = ~A; " (var-c-name var) arg-lvalue))
  283.       (emit-source-line tree)
  284.       (emit-c "~%goto ~A;~%" (proc-start-label proc)))
  285.     (progn
  286.       (emit-source-line tree)
  287.       (maybe-emit-assignment result-var)
  288.       (if (config-indirect-calls? *config*)
  289.           (emit-c "ICALL(~A) (" (emit-data name))
  290.           (let ((c-name (add-external-proc name)))
  291.         (emit-c "(LP) ~A(" c-name)))
  292.       (if (code-mv? tree)
  293.           (emit-c "MV_CALL(~A,~D)" (code-mv-holder tree) argc)
  294.           (emit-c "~D" argc))
  295.       (loop for arg-lvalue in arg-lvalues
  296.         do (emit-c ", ~A" arg-lvalue))
  297.       (emit-c ");~%")
  298.       (emit-return-if-tail result-var tree rvar rtype)))))
  299.  
  300. (defun emit-unnamed-call (tree rvar rtype)
  301.   (let* ((result-var (result-var-name rvar))
  302.      (arg-lvalues (mapcar #'(lambda (arg)
  303.                   (emit-code arg :live t))
  304.                   (function-call-args tree)))
  305.      (func-var (emit-code (unnamed-call-function-form tree) :live t))
  306.      (func (case (code-out-type (unnamed-call-function-form tree))
  307.          (compiled-function func-var)
  308.          (symbol (format nil "LDREF(~A,SYMBOL,function)" func-var))
  309.          (t (format nil "COERCE_TO_FUNCTION(~A)" func-var))))
  310.      (argc (+ (if (unnamed-call-spread-args? tree) 1 0)
  311.           (length arg-lvalues))))
  312.     (emit-source-line tree)
  313.     (maybe-emit-assignment result-var)
  314.     (if (unnamed-call-spread-args? tree)
  315.     (emit-c "p_lsp_APPLY(")
  316.     (emit-c "CODE_PTR(~A)(" func))
  317.     (if (code-mv? tree)
  318.     (emit-c "MV_CALL(~A,~D)" (code-mv-holder tree) argc)
  319.     (emit-c "~D" argc))
  320.     (when (unnamed-call-spread-args? tree)
  321.       (emit-c ", ~A" func))
  322.     (loop for arg-lvalue in arg-lvalues do
  323.       (emit-c ", ~A" arg-lvalue))
  324.     (emit-c ");~%")
  325.     (emit-return-if-tail result-var tree rvar rtype)))
  326.   
  327. (defun emit-primitive-call (tree rvar rtype)
  328.   (let* ((finfo (function-call-info tree))
  329.      (emitter (primitive-info-emitter finfo))
  330.      (result-var (result-var-name rvar))
  331.      (arg-lvalues
  332.       (mapcar #'(lambda (arg type)
  333.               (convert-lisp->c type (emit-code arg :live t) arg))
  334.           (function-call-args tree)
  335.           (function-info-in-types finfo)))
  336.      (out-type (car (primitive-info-out-types finfo)))
  337.      (out-converter (c->lisp-converter out-type)))
  338.     (emit-source-line tree)
  339.     (if (eq out-type c-type-if-test)
  340.     (if (eq (code-out-type tree) c-type-if-test)
  341.         (progn (emit-c "if (")
  342.            (apply emitter arg-lvalues))
  343.         (progn (maybe-emit-assignment result-var)
  344.            (emit-c "(")
  345.            (apply emitter arg-lvalues)
  346.            (emit-c " ? T : NIL);~%")))
  347.     (if (eq out-type (code-out-type tree))
  348.         (apply emitter arg-lvalues)
  349.         (progn (unless (null (primitive-info-outs finfo))
  350.              (maybe-emit-assignment result-var))
  351.            (emit-c out-converter)
  352.            (apply emitter arg-lvalues)
  353.            (emit-c ");~%"))))
  354.     (emit-return-if-tail result-var tree rvar rtype)))
  355.  
  356. (defun emit-foreign-call (tree rvar rtype)
  357.   (let* ((foreign-info (function-call-info tree))
  358.      (result-var (result-var-name rvar))
  359.      (arg-lvalues (mapcar #'(lambda (arg)
  360.                   (emit-code arg :live t))
  361.                   (function-call-args tree)))
  362.      (out-type (first (foreign-info-out-type-objects foreign-info)))
  363.      (out-converter (c->lisp-converter out-type)))
  364.     (record-foreign-function-reference foreign-info)
  365.     (emit-source-line tree)
  366.     (unless (eq out-type c-type-void)
  367.       (maybe-emit-assignment result-var))
  368.     (emit-c out-converter)
  369.     (emit-c "~A(" (foreign-info-foreign-name foreign-info))
  370.     (iterate emit-args ((argls arg-lvalues)
  371.             (args (function-call-args tree))
  372.             (types (foreign-info-in-type-objects foreign-info)))
  373.       (if (null argls)
  374.       (emit-c "));~%")
  375.       (let ((arg-lvalue (car argls))
  376.         (arg (car args))
  377.         (type (car types)))
  378.         (emit-c (convert-lisp->c type arg-lvalue arg))
  379.         (unless (null (cdr argls)) (emit-c ", "))
  380.         (emit-args  (cdr argls)
  381.             (cdr args)
  382.             (cdr types)))))
  383.     (emit-return-if-tail (if (eq out-type c-type-void)
  384.                  "NIL"
  385.                  result-var)
  386.              tree rvar rtype)))
  387.  
  388. (defun code-with-side-effects? (tree)
  389.   (not (typep tree 'constant)))
  390.  
  391. (defun emit-branch (tree rvar rtype)
  392.   (etypecase tree
  393.     (if (emit-if tree rvar rtype))
  394.     (switch (emit-switch tree rvar rtype))))
  395.  
  396. (defun emit-if (tree rvar rtype)
  397.   (emit-source-line tree)
  398.   (if (null (if-then tree))
  399.       (if (null (if-else tree))
  400.       (error "Why didn't improve zap this IF?")
  401.       (emit-partial-if tree rvar rtype #'if-else t))
  402.       (if (null (if-else tree))
  403.       (emit-partial-if tree rvar rtype #'if-then nil)
  404.       (emit-full-if tree rvar rtype))))
  405.  
  406. (defun emit-switch (tree rvar rtype)
  407.   (let* ((switch-var (result-var-name rvar))
  408.      (test-lvalue (emit-code (switch-test tree) :live t)))
  409.     (emit-source-line tree)
  410.     (emit-c "switch ((int) ~A) {~%" test-lvalue)
  411.     (loop for key in (switch-keys tree)
  412.       for consequent in (switch-consequents tree)
  413.       do (progn (dolist (k key)
  414.               ;; HEY! Fix this when we can have raw data selector
  415.               (emit-c "case ~D:~%" (ash k 1))) ; int -> fixnum
  416.             (emit-code consequent switch-var rtype)
  417.             (emit-c "break;~%")))
  418.     (emit-c "default:~%")
  419.     (emit-code (switch-default tree) switch-var rtype)
  420.     (emit-c "break;~%}~%")
  421.     switch-var))
  422.  
  423. (defun emit-full-if (tree rvar rtype)
  424.   (let* ((if-var (result-var-name rvar))
  425.      (test-lvalue (emit-code (if-test tree) :live t)))
  426.     (if (branch-inline-test? tree)
  427.     (emit-c ") {~%")
  428.     (emit-c "if (~A != NIL) {~%" test-lvalue))
  429.     (emit-code (if-then tree) if-var rtype)
  430.     (emit-lc (if-else tree) "} else {~%")
  431.     (emit-code (if-else tree) if-var rtype)
  432.     (emit-c "}~%")
  433.     if-var))
  434.  
  435. (defun emit-partial-if (tree rvar rtype branch-selector invert-test?)
  436.   (let ((if-var (result-var-name rvar))
  437.     (test-lvalue (emit-code (if-test tree) :live t)))
  438.     (if (branch-inline-test? tree)
  439.     (if invert-test?
  440.         (emit-c " == 0) {~%")
  441.         (emit-c ") {~%"))
  442.     (if invert-test?
  443.         (emit-c "if (~A == NIL) {~%" test-lvalue)
  444.         (emit-c "if (~A != NIL) {~%" test-lvalue)))
  445.     (emit-code (funcall branch-selector tree) if-var rtype)
  446.     (emit-c "}~%")
  447.     if-var))
  448.  
  449. (defun emit-scope-seq (tree rvar rtype)
  450.   (let* ((cp (scope-seq-control-point tree))
  451.      (receive-var (result-var-name rvar)))
  452.     (etypecase cp
  453.       (dynamic-scope-control-point
  454.        (let ((tag-obj (emit-code (dynamic-scope-control-point-tag-name cp)
  455.                  :live
  456.                  t))
  457.          (mv-holder (code-mv-holder tree)))
  458.      (emit-c "BEGIN_CATCH(~A,~A);~%"
  459.          tag-obj (if (null mv-holder) 0 mv-holder))
  460.      (let ((seq-var (emit-body (seq-body tree) rvar rtype)))
  461.        (unless (or (eq receive-var :dead)
  462.                (eq receive-var seq-var))
  463.          (emit-c "~A = ~A;~%" receive-var seq-var)))
  464.      (emit-c "END_CATCH(~A);~%" (if (eq receive-var :dead)
  465.                     (tmp-var-name)
  466.                     receive-var))
  467.      (emit-return-if-tail receive-var tree rvar rtype)))
  468.       (static-scope-control-point
  469.        (setf (scope-control-point-receive-var cp) receive-var)
  470.        (let ((seq-var (emit-body (seq-body tree) rvar rtype)))
  471.      (if (code-tail? tree)
  472.          nil
  473.          (progn (unless (eq receive-var :dead)
  474.               (emit-c "~A = ~A;~%" receive-var seq-var))
  475.             (emit-c "~A:;~%" (static-scope-control-point-c-name cp))
  476.             receive-var)))))))
  477.  
  478. (defun emit-tag-seq (tree rvar rtype)
  479.   (loop for cp in (tag-seq-control-points tree)
  480.     when (dynamic-tag-control-point-p cp)
  481.     count cp into dynamic-tag-count
  482.     and
  483.     do (let ((tag-obj (emit-code (dynamic-tag-control-point-tag-name cp)
  484.                      :live
  485.                      t)))
  486.          (emit-c "BEGIN_DYNAMIC_TAG(~A,~A)~%"
  487.              tag-obj
  488.              (tag-control-point-c-name cp)))
  489.     finally (progn (emit-body (seq-body tree) rvar rtype)
  490.                (dotimes (i dynamic-tag-count)
  491.              (emit-c "END_DYNAMIC_TAG~%"))))
  492.   (emit-return-if-tail "NIL" tree rvar rtype))
  493.            
  494. (defun emit-control-transfer (tree)
  495.   (etypecase tree
  496.     (scope-control-transfer (emit-scope-control-transfer tree))
  497.     (tag-control-transfer (emit-tag-control-transfer tree))))
  498.  
  499. (defun emit-scope-control-transfer (tree)
  500.   (let ((point (control-transfer-destination-point tree))
  501.     (value-tree (scope-control-transfer-send-value tree)))
  502.     (etypecase point
  503.     (static-scope-control-point
  504.      (let ((send-var (emit-code value-tree :live t))
  505.            (scope (scope-control-point-parent point)))
  506.        (if (code-tail? scope)
  507.            (emit-return-if-tail send-var scope :live t)
  508.            (let ((rvar (scope-control-point-receive-var point)))
  509.          (unless (eq rvar :dead)
  510.            (emit-c "~A = ~A;~%" rvar send-var))
  511.          (emit-c "goto ~A;~%"
  512.              (static-scope-control-point-c-name point))))))
  513.       (dynamic-scope-control-point
  514.        (let ((tag-obj
  515.           (emit-code (dynamic-scope-control-point-tag-name point) :live t))
  516.          (throw-mv-holder
  517.           (scope-control-point-receive-var point)))
  518.      (when (eq throw-mv-holder :dead)
  519.        (error "fix me"))
  520.      (emit-c "BEGIN_MV_CALL(~A,~D);~%" throw-mv-holder 0)
  521.      (let ((send-var (emit-code value-tree :live t)))
  522.        (emit-c "THROW(~A,~A,~A);~%"
  523.            tag-obj send-var throw-mv-holder))
  524.      (emit-c "END_MV_CALL;~%"))))))
  525.  
  526. (defun emit-tag-control-transfer (tree)
  527.   (let ((point (control-transfer-destination-point tree)))
  528.     (etypecase point
  529.       (static-tag-control-point
  530.        (emit-c "goto ~A;~%" (static-tag-control-point-c-name point)))
  531.       (dynamic-tag-control-point
  532.        (let ((tag-obj (emit-code (dynamic-tag-control-point-tag-name point)
  533.                  :live
  534.                  t)))
  535.      (emit-c "GOTO_DYNAMIC_TAG(~A);~%" tag-obj))))))
  536.  
  537.            
  538. (defun emit-tag-control-point (tree)
  539.   (emit-c "~A:;~%" (tag-control-point-c-name tree)))
  540.  
  541. (defun emit-unwind-protect (tree rvar rtype)
  542.   (emit-c "BEGIN_UW_PROTECT_BODY~%")
  543.   (let ((value (emit-code (unwind-protect-protected-form tree) :live t)))
  544.     (emit-c "BEGIN_UW_PROTECT_CLEANUP~%")
  545.     (emit-code (unwind-protect-cleanup-form tree) :live t)
  546.     (emit-c "CONTINUE_FROM_PROTECT~%")
  547.     (emit-return-if-tail value tree rvar rtype)))
  548.  
  549. (defun lookup-outer-environment-offset (var)
  550.   (let* ((inner (var-innermost-proc var))
  551.      (outer (if (top-level-proc-p inner)
  552.             inner
  553.             (first (last (inner-proc-parent-chain inner))))))
  554.     (position var (top-level-proc-oe-vars outer))))
  555.  
  556. (defun genstring (name)
  557.   (concatenate 'string name (write-to-string (incf *string-counter*))))
  558.   
  559. (defun tmp-var-name ()
  560.   (concatenate 'string "t" (write-to-string (incf *tmp-var-counter*))))
  561.  
  562. (defun emit-proc-extern-declaration (tree)
  563.   (let* ((info (proc-var-info tree))
  564.      (hairy? (var-info-hairy? info)))
  565.     (emit-k "extern ")
  566.     (if hairy?
  567.      (if (c-compiler-ansi-var-args? (machine-c-compiler *target-machine*))
  568.          (emit-ansi-proc-prototype tree *k-stream*)
  569.          (emit-k "LP ~A()" (proc-c-name tree)))
  570.      (if (c-compiler-ansi-fixed-args?
  571.           (machine-c-compiler *target-machine*))
  572.          (emit-ansi-proc-prototype tree *k-stream*)
  573.          (emit-k "LP ~A()" (proc-c-name tree))))
  574.     (emit-k ";~%")
  575.     (setf (gethash (proc-name tree) *external-procs*)
  576.       :done)))
  577.  
  578. (defun emit-proc-prototype (tree)
  579.   (let* ((info (proc-var-info tree))
  580.      (hairy? (var-info-hairy? info)))
  581.     (if hairy?
  582.     (if (c-compiler-ansi-var-args? (machine-c-compiler *target-machine*))
  583.         (emit-ansi-proc-prototype tree *c-stream*)
  584.         (emit-non-ansi-hairy-proc-decl tree))
  585.     (if (c-compiler-ansi-fixed-args?
  586.           (machine-c-compiler *target-machine*))
  587.         (emit-ansi-proc-prototype tree *c-stream*)
  588.         (emit-non-ansi-fixed-proc-decl tree)))))
  589.  
  590. (defun emit-ansi-proc-prototype (tree emitter-stream)
  591.   (let ((info (proc-var-info tree)))
  592.     (format emitter-stream "LP ~A(ARGC argc" (proc-c-name tree))
  593.     (loop for var in (var-info-requireds info)
  594.       do (format emitter-stream  ", ~ALP ~A"
  595.              (proc-volatile tree) (var-c-name var)))
  596.     (if (var-info-hairy? info)
  597.     (format emitter-stream  ",...)")
  598.     (format emitter-stream ")"))))
  599.  
  600. (defun emit-non-ansi-fixed-proc-decl (tree)
  601.   (let ((info (proc-var-info tree)))
  602.     (emit-c "LP ~A(argc" (proc-c-name tree))
  603.     (loop for var in (var-info-requireds info)
  604.       do (emit-c  ", ~A" (var-c-name var)))
  605.     (emit-c ")~%")
  606.     (emit-c "      ARGC argc; ")
  607.     (loop for var in (var-info-requireds info)
  608.       do (emit-c  "~A LP ~A;" 
  609.               (proc-volatile tree) (var-c-name var)))))
  610.  
  611. (defun emit-non-ansi-hairy-proc-decl (tree)
  612.   (emit-c "LP ~A(va_alist) va_dcl" (proc-c-name tree)))
  613.  
  614. (defun emit-required-argc-check (tree)
  615.   (when (config-argc-check? *config*)
  616.     (let ((len (length (var-info-requireds (proc-var-info tree)))))
  617.       (emit-c "if (argc != ~D) wna(argc,~D);~%" len len)))
  618.   (setup-oe-if-needed tree))
  619.  
  620. (defun emit-misc-storage-decls (info)
  621.   (unless (null (var-info-restv-var info))
  622.     (emit-c "RESTV_HOLDER(restv_vector);~%"))
  623.   (let ((rest-var (var-info-rest-var info)))
  624.     (when (and (not (null rest-var)) (var-dynamic-extent? rest-var))
  625.       (emit-c "DYNAMIC_REST_HOLDER(rest_conses);~%"))
  626.     (emit-c "int real_argc;~%")))
  627.  
  628. (defun emit-hairy-arg-code (tree)
  629.   (let* ((info (proc-var-info tree))
  630.      (reqs (var-info-requireds info))
  631.      (num-requireds (length reqs)))
  632.     (emit-misc-storage-decls info)
  633.     (if (c-compiler-ansi-var-args? (machine-c-compiler *target-machine*))
  634.     (emit-c "BEGIN_ANSI_VAR_ARGS(~A);~%"
  635.         (if (null reqs)
  636.             "argc"
  637.             (var-c-name (first (last reqs)))))
  638.     (progn (emit-c "ARGC argc;~%")
  639.            (emit-c "BEGIN_NON_ANSI_VAR_ARGS;~%")
  640.            (emit-c "argc = (ARGC) NEXT_VAR_ARG;~%")
  641.            (loop for v in reqs do (emit-c "~A = NEXT_VAR_ARG;~%"
  642.                           (var-c-name v)))
  643.            (emit-c "~%~%")))
  644.     (setup-oe-if-needed tree)
  645.     (emit-c "real_argc = REAL_ARGC(argc);~%")
  646.     (when (config-argc-check? *config*)
  647.       (emit-c "if (real_argc < ~D) wna_low(real_argc,~D);~%"
  648.           num-requireds num-requireds)
  649.       (when (and (null (var-info-restv-var info))
  650.          (null (var-info-rest-var info)))
  651.     (let ((max-argc (+ num-requireds
  652.                (length (var-info-optionals info)))))
  653.       (emit-c "if (real_argc > ~D) wna_high(real_argc,~D);~%"
  654.           max-argc max-argc))))
  655.     (emit-hairy-var-code info
  656.              "NEXT_VAR_ARG"
  657.              "END_VAR_ARGS")))
  658.  
  659. (defun emit-hairy-value-code (info mv-holder)
  660.   (emit-c "real_argc = GET_MV_RETURN_COUNT(~A);~%" mv-holder)
  661.   (emit-c "BEGIN_VAR_VALUES;~%")
  662.   (emit-hairy-var-code info
  663.               (format nil "NEXT_VAR_VALUE(~A)" mv-holder)
  664.               "END_VAR_VALUES"))
  665.  
  666. (defun emit-hairy-var-code (info next-var end-var)
  667.   (let ((num-requireds (length (var-info-requireds info))))
  668.     (emit-optional-arg-code (+ num-requireds 1)
  669.                 (var-info-optionals info)
  670.                 next-var)
  671.     (emit-rest-arg-code info next-var)
  672.     (emit-restv-arg-code info next-var)
  673.     (emit-keyword-arg-code (var-info-keys info)
  674.                (var-info-rest-var info))
  675.     (emit-c "~A;~%" end-var)))
  676.   
  677. (defun emit-optional-arg-code (start opts next-var-arg)
  678.   (loop for opt being the elements of opts using (index i) do
  679.     (progn
  680.       (emit-c "if (real_argc < ~D) {~%" (+ start i))
  681.       (let ((lvalue (emit-code (optional-init-form opt) :live t)))
  682.         (emit-c "~A = ~A;~%"
  683.             (var-c-name (optional-var opt))
  684.             lvalue))
  685.       (unless (null (optional-supplied-var opt))
  686.         (emit-c "~A = NIL;~%"
  687.             (var-c-name (optional-supplied-var opt))))
  688.       (emit-c "} else {~%")
  689.       (emit-c "~A = ~A;~%" (var-c-name (optional-var opt)) next-var-arg)
  690.       (unless (null (optional-supplied-var opt))
  691.         (emit-c "~A = T;~%"
  692.             (var-c-name (optional-supplied-var opt))))
  693.       (emit-c "}~%"))))
  694.  
  695. (defun emit-rest-arg-code (info next-var-arg)
  696.   (unless (null (var-info-rest-var info))
  697.     (emit-c "~A(~A,~D,~A);~%"
  698.         (if (var-dynamic-extent? (var-info-rest-var info))
  699.         "DYNAMIC_RESTIFY"
  700.         "RESTIFY")
  701.         (var-c-name (var-info-rest-var info))
  702.           (+ (length (var-info-requireds info))
  703.            (length (var-info-optionals info))
  704.            1)
  705.         next-var-arg)))
  706.  
  707. (defun emit-restv-arg-code (info next-var-arg)
  708.   (unless (null (var-info-restv-var info)) 
  709.     (emit-c "RESTVIFY(~A,~D,~A);~%"
  710.         (var-c-name (var-info-restv-var info))
  711.           (+ (length (var-info-requireds info))
  712.            (length (var-info-optionals info))
  713.            1)
  714.         next-var-arg)))
  715.  
  716. (defun emit-keyword-arg-code (keys rest-var)
  717.   (loop for key in keys do
  718.     (progn
  719.       (unless (null (key-supplied-var key))
  720.         (emit-c "~A = T;~%" (var-c-name (key-supplied-var key))))
  721.       ;; HEY! pass allow other keys along...
  722.       (emit-c "BEGIN_KEY_INIT(~A,~A,~A)~%"
  723.           (var-c-name (key-var key))
  724.           (emit-code (key-name key) :live t)
  725.           (var-c-name rest-var))
  726.       (unless (null (key-supplied-var key))
  727.         (emit-c "~A = NIL;~%"   (var-c-name (key-supplied-var key))))
  728.       (let ((init-lvalue (emit-code (key-init-form key) :live t)))
  729.         (emit-c "~A = ~A;~%" (var-c-name (key-var key)) init-lvalue))
  730.       (emit-c "END_KEY_INIT~%"))))
  731.  
  732.  
  733. ;;; Emit direct array refs for simple-vectors of known type
  734. ;;; and for simple-arrays of known type and all but 1 dim
  735. ;;; 1d: x = ((double (*)) ptr)[1];
  736. ;;; 2d: x = ((double (*)[3]) ptr)[1][2];
  737. (defun inline-array-op? (call)
  738.   (let ((name (function-call-name call)))
  739.     (and (typep call '(or named-call foreign-call))
  740.      (member name '(aref vref set-aref set_vref))
  741.      (let* ((array-arg (if (member name '(aref vref))
  742.                    (first (function-call-args call))
  743.                    (second (function-call-args call))))
  744.         (array-type (code-out-type array-arg)))
  745.        (and (listp array-type)
  746.         (eq (car array-type) 'simple-array)
  747.         ;; HEY! fix this so that bit ops are inlined also
  748.         (not (equal (second array-type) '(integer 0 1)))
  749.         (let ((dims (third array-type)))
  750.           ;; Don't need to know first dimension
  751.           (every #'numberp (cdr dims))))))))
  752.  
  753. (defun emit-inline-array-op (call rvar rtype)
  754.   (ecase (function-call-name call)
  755.     ((aref vref) (emit-inline-array-ref call rvar rtype))
  756.     ((set-aref set_vref) (emit-inline-array-def call rvar rtype))))
  757.  
  758. (defun emit-inline-array-ref (call rvar rtype)
  759.   (let* ((array-arg (first (function-call-args call)))
  760.      (index-args (rest (function-call-args call)))
  761.      (array-type (code-out-type array-arg))
  762.      (element-type (second array-type))
  763.      (declared-dims (third array-type))
  764.      (c-type-object (lisp-array-type->c-type-object element-type))
  765.      (result-var (result-var-name rvar))
  766.      (array (emit-code array-arg :live t))
  767.      (indices (loop for index in index-args
  768.             collect (emit-code index :live t)))
  769.      (real-array (if (> (length indices) 1)
  770.              (format nil "((LP) DEREF(~A))" array)
  771.              array)))
  772.     (unless (eq result-var :dead)
  773.       (emit-c
  774.        "~A = (LP) ~A(((~A (*)~{[~A]~}) (~A - 1))~{[FX_TO_INT(~A)]~});~%"
  775.        result-var
  776.        (c-type-info-convert-to-lisp c-type-object)
  777.        (c-type-info-c-type c-type-object)
  778.        (cdr declared-dims)
  779.        real-array
  780.        indices)
  781.       (emit-return-if-tail result-var call :live rtype))))
  782.  
  783. (defun emit-inline-array-def (call rvar rtype)
  784.   (let* ((value-arg (first (function-call-args call)))
  785.      (array-arg (second (function-call-args call)))
  786.      (index-args (cddr (function-call-args call)))
  787.      (array-type (code-out-type array-arg))
  788.      (element-type (second array-type))
  789.      (declared-dims (third array-type))
  790.      (c-type-object (lisp-array-type->c-type-object element-type))
  791.      (value (emit-code value-arg rvar rtype))
  792.      (array (emit-code array-arg :live t))
  793.      (indices (loop for index in index-args
  794.             collect (emit-code index :live t)))
  795.      (real-array (if (> (length indices) 1)
  796.              (format nil "((LP) DEREF(~A))" array)
  797.              array)))
  798.     (emit-c
  799.      "((~A (*)~{[~A]~}) (~A - 1))~{[FX_TO_INT(~A)]~} = (~A)~A(~A);~%"
  800.      (c-type-info-c-type c-type-object)
  801.      (cdr declared-dims)
  802.      real-array
  803.      indices
  804.      (c-type-info-c-type c-type-object)
  805.      (c-type-info-convert-to-c c-type-object)
  806.      value)
  807.     (emit-return-if-tail value call :live t)))
  808.  
  809. ;;; This is sort of gross. 
  810. (defun lisp-array-type->c-type-object (type)
  811.   (select (type->element-type-tag type)
  812.     (element-type-bit (error "HEY! fix this.") c-type-int32)
  813.     (element-type-signed-8bit c-type-int8)
  814.     (element-type-unsigned-8bit c-type-uint8)
  815.     (element-type-signed-16bit c-type-int16)
  816.     (element-type-unsigned-16bit c-type-uint16)
  817.     (element-type-signed-32bit c-type-int32)
  818.     (element-type-unsigned-32bit c-type-uint32)
  819.     (element-type-ptr c-type-lptr)
  820.     (element-type-float c-type-double)
  821.     (element-type-char c-type-char)))
  822.  
  823. (defun emit-source-line (tree)
  824.   (when (config-lisp-line-numbers? *config*)
  825.     (let* ((line (code-line tree)))
  826.       (emit-c "# ~D~%" line)
  827.       (format t "Line number: ~D, tree: ~A~%" line tree))))
  828.  
  829.  
  830. ;; s = NEW_FPTR(stat(),s_w_STAT);
  831. ;; x = INT_TO_FX((struct stat*) (LDREF(FPTR,s,data)))->st_spare1);
  832. ;; y = MAKE_FPTR((struct stat*) (LDREF(FPTR,s,data)))->st_time-t, s_w_TIME_T);
  833. ;; z = INT_TO_FX((((struct stat*) (LDREF(FPTR,s,data)))->stat-st-spare4);
  834. ;; ((struct stat*) (LDREF(FPTR,s,data)))->st_spare1) = FX_TO_INT(z);
  835.  
  836. (defun emit-c-struct-op (tree rvar rtype)
  837.   (etypecase tree
  838.     (c-struct-ref (emit-c-struct-ref tree rvar rtype))
  839.     (c-struct-def (emit-c-struct-def tree rvar rtype))))
  840.  
  841. (defun emit-c-struct-ref (tree rvar rtype)
  842.   (let* ((info (c-struct-op-struct-info tree))
  843.      (struct-name (c-struct-info-name info))
  844.      (field (c-struct-op-field tree))
  845.      (struct (emit-code (first (function-call-args tree)) :live t))
  846.      (result-var (result-var-name rvar)))
  847.     (record-c-info-reference info)
  848.     (unless (eq result-var :dead)
  849.       (emit-c
  850.        "~A = ~A(((struct ~A *) (RAW_FPTR(~A)))->~A));~%"
  851.        result-var
  852.        (c->lisp-converter
  853.     (c-type-name->c-type-object (c-struct-slot-type field)))
  854.        struct-name
  855.        struct
  856.        (c-struct-slot-c-name field))
  857.       (emit-return-if-tail result-var tree :live rtype))))
  858.  
  859. (defun emit-c-struct-def (tree rvar rtype)
  860.   (let* ((info (c-struct-op-struct-info tree))
  861.      (struct-name (c-struct-info-name info))
  862.      (field (c-struct-op-field tree))
  863.      (struct (emit-code (first (function-call-args tree)) rvar rtype))
  864.      (value (emit-code (second (function-call-args tree)) :live t))
  865.      (result-var (result-var-name rvar)))
  866.     (record-c-info-reference info)
  867.     (unless (eq result-var :dead)
  868.       (emit-c
  869.        "ref = ~A;~%"
  870.        (c->lisp-converter
  871.     (c-type-name->c-type-object (c-struct-slot-type field)))
  872.        struct-name
  873.        struct
  874.        (c-struct-slot-c-name field)
  875.        value))
  876.     (emit-return-if-tail value tree :live rtype)))
  877.  
  878. (defun record-c-info-reference (info)
  879.   (pushnew info *referenced-c-info*))
  880.  
  881. (defun record-c-struct-reference (info)
  882.   (record-c-info-reference info))
  883.  
  884. (defun record-foreign-function-reference (info)
  885.   ;; HEY! also record c struct refs
  886.   (record-c-info-reference info))
  887.  
  888. (defun emit-referenced-c-definitions ()
  889.   (dolist (i *referenced-c-info*)
  890.     (emit-c-definition i))
  891.   (emit-k "~%~%"))
  892.  
  893. (defun emit-c-definition (info)
  894.   (etypecase info
  895.     (c-struct-info (emit-c-struct-definition info))
  896.     (foreign-info (emit-foreign-definition info))))
  897.  
  898. (defun emit-c-struct-definition (info)
  899.   (emit-k "struct ~A {~%" (c-struct-info-name info))
  900.   (loop for slot in (c-struct-info-slots info)
  901.     do (emit-k "~A;~%"
  902.            (c-type-decl
  903.             (c-type-name->c-type-object (c-struct-slot-type slot))
  904.             (c-struct-slot-c-name slot))))
  905.   (emit-k "};~%"))
  906.  
  907. (defun emit-foreign-definition (info)
  908.   (emit-k "extern ~A ~A("
  909.       (c-type-spec (car (foreign-info-out-type-objects info)))
  910.       (foreign-info-foreign-name info))
  911.   (when (c-compiler-ansi-fixed-args? (machine-c-compiler *target-machine*))
  912.     (loop for out-type on (foreign-info-in-type-objects info)
  913.       do (emit-k "~A" (c-type-spec (car out-type)))
  914.       unless (null (cdr out-type))
  915.       do (emit-k ", ")))
  916.   (emit-k ");~%"))
  917.                  
  918. (defun convert-lisp->c (type arg tree)
  919.   (if (and (constant-p tree)
  920.        (fixnump (constant-data tree))
  921.        (not (null (c-type-info-constant-to-c type))))
  922.       (format nil "~D" (funcall (c-type-info-constant-to-c type)
  923.                 (constant-data tree)))
  924.       (etypecase type
  925.     (c-type-info (let ((converter (c-type-info-convert-to-c type)))
  926.                (if (null converter)
  927.                arg
  928.                (format nil "~A(~A)" converter arg))))
  929.     (c-array-info (typecase (c-array-info-element-type type)
  930.             (c-struct-info (format nil "RAW_FPTR(~A)" arg))
  931.             ;; HEY! Fix this
  932.             (t (format nil "lisp_to_c_array(~A)" arg))))
  933.     (c-struct-info (error "struct case")))))
  934.                  
  935. (defun c->lisp-converter (type)
  936.   (etypecase type
  937.     (c-type-info (format nil "~A(" (c-type-info-convert-to-lisp type)))
  938.     (c-array-info
  939.      (let ((element-type (c-array-info-element-type type))
  940.        (dims (c-array-info-dimensions type)))
  941.        (case (length dims)
  942.      (0 (typecase element-type
  943.           (c-struct-info
  944.            (let ((name (emit-lref (c-struct-info-name element-type))))
  945.          (format nil "NEW_FPTR(~A, " name)))
  946.           (t (select element-type
  947.            (c-type-char "c_to_lisp_string((LP) ")
  948.            (t (error "fix me!"))))))
  949.      (1 (typecase element-type
  950.           (c-struct-info (error "fix me"))
  951.           (t (select element-type
  952.            (c-type-char "c_to_lisp_string((LP) ")
  953.            (t (error "fix me!"))))))
  954.      (t (error "finish multi-array converters")))))
  955.     (c-struct-info (error "write struct"))))
  956.  
  957. (defun c-type-spec (type)
  958.   (etypecase type
  959.     (c-type-info (c-type-info-c-type type))
  960.     (c-array-info
  961.      (format nil "~A *" (c-type-spec (c-array-info-element-type type))))
  962.     (c-struct-info (format nil "struct ~A" (c-struct-info-name type)))))
  963.  
  964. (defun c-type-decl (type var-name)
  965.   (etypecase type
  966.     (c-type-info (format nil "~A ~A" (c-type-info-c-type type) var-name))
  967.     (c-array-info
  968.      (let ((dims (c-array-info-dimensions type))
  969.        (type-spec (c-type-spec (c-array-info-element-type type))))
  970.        (if (null dims)
  971.        (format nil "~A *~A" type-spec var-name)
  972.        (format nil "~A ~A~{[~D]~}" type-spec var-name dims))))
  973.     (c-struct-info (format nil "struct ~A ~A"
  974.                (c-struct-info-name type) var-name))))
  975.  
  976. (defun c-type-name->c-type-object (type)
  977.   (if (atom type)
  978.       (case type
  979.     (char c-type-char)
  980.     (int8 c-type-int8)
  981.     ((unsigned-char unsigned-int8) c-type-uint8)
  982.     ((short int16) c-type-int16)
  983.     ((unsigned-short unsigned-int16) c-type-uint16)
  984.     ((int long int31) c-type-int31)
  985.     ((unsigned-long unsigned-int31 uint31) c-type-uint31)
  986.     (int32 c-type-int32)
  987.     ((unsigned-int32 uint32) c-type-uint32)
  988.     (double c-type-double)
  989.     (fptr c-type-fptr)
  990.     ((void nil) c-type-void)
  991.     (if-test c-type-if-test)
  992.     (char* c-type-char-string)
  993.     ((t) c-type-lptr)
  994.     (t (lookup-named-c-type type)))
  995.       (cond ((eq (first type) 'array)    ; (array <type> dims...)
  996.          (make-c-array-info :element-type (c-type-name->c-type-object
  997.                            (second type))
  998.                 :dimensions (cddr type)))
  999.         ((eq (second type) '*)    ; pointers = arrays in C
  1000.          (make-c-array-info :element-type (c-type-name->c-type-object
  1001.                            (first type))
  1002.                 :dimensions nil))
  1003.         (t (error "Illegal type spec: ~A" type)))))
  1004.  
  1005. (defun lookup-named-c-type (name)
  1006.   (or (gethash name *c-named-types*)
  1007.       (error "Unknown foreign type: ~A" name)))
  1008.  
  1009. (defun define-c-type-name (name type)
  1010.   (setf (gethash name *c-named-types*)
  1011.     (c-type-name->c-type-object type)))
  1012.  
  1013. (defun define-c-structure (info)
  1014.   ;; do defsetfs and deftype here ala defstruct
  1015.   (let ((name (c-struct-info-name info)))
  1016.     (setf (gethash name *c-named-types*) info)
  1017.     name))
  1018.  
  1019. (defun parse-c-struct-info (name fields)
  1020.   (make-c-struct-info :name name
  1021.               :slots (loop for (type name) in fields
  1022.                    collect (make-c-struct-slot
  1023.                         :name name
  1024.                         :type type))))
  1025.  
  1026. (defun lookup-c-struct-field (info field-name)
  1027.   (or (find field-name (c-struct-info-slots info)
  1028.         :key #'c-struct-slot-name)
  1029.       (error "C Structure ~A does not have a field named ~S"
  1030.          (c-struct-info-name info)
  1031.          field-name)))
  1032.